perm filename PCALL.SAI[PNT,HE]12 blob
sn#549901 filedate 1980-12-08 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00013 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 ENTRY
C00003 00003 ! swap to E, then resume
C00006 00004 ! readcode
C00011 00005 ! editcall,renamecall
C00021 00006 ! readcall,renmcall,writecall,photocall,helpcall
C00024 00007 ! display: update,arrow,displaycall,redisplaycall,showcall,nodisplaycall
C00030 00008 ! graphcall
C00031 00009 ! eeditcall
C00032 00010 ifc false thenc
C00039 00011 ! deletecall,definecall,notavailcall,exitcall
C00048 00012 ! requirecall,bailcall,setstatuscall,readmesscall,stopmesscall
C00052 00013 ! savecorecall
C00054 ENDMK
C⊗;
ENTRY;
BEGIN "PCALL"
COMMENT routines which are not available in AL;
DEFINE $PCALL=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
! swap to E, then resume ;
PROCEDURE ESWAP(REFERENCE STRING MODIFY_STRING);
BEGIN
! this procedure will save the current state of the POINTY program in
the file XXXXXX.DMP[PNT,HE], and swap to E to a file called E$TEMP.TMP[PNT,HE]
which it writes with the contents of MODIFY_STRING,
and allows the user to modify. When the user exits E
by doing <control>XRUN, the POINTY program resumes by swapping back
XXXXXX.DMP[PNT,HE] and renaming it POINTY, and then reading in E$TEMP.TMP[PNT,HE]
as the input string MODIFY_STRING;
INTEGER ARRAY EARRAY[0:'17];
INTEGER ARRAY SAVADR[0:4],GETADR[0:5];
STRING COREIMAGEFILE,E$TEMP;
E$TEMP←"E$TEMP.TMP[PNT,HE]";
WRITEFILE(E$TEMP,MODIFY_STRING);
COREIMAGEFILE←"XXXXXX.DMP[PNT,HE]";
SAVADR[0]←CVSIX("DSK");
SAVADR[1]←CVFIL(COREIMAGEFILE,SAVADR[2],SAVADR[4]);
GETADR[0]←CVSIX("SYS");
GETADR[1]←CVFIL("E.DMP[1,3]",GETADR[2],GETADR[4]);
GETADR[3]←1;
GETADR[5]←CALL(0,"DSKPPN"); ! use current dsk ppn;
ARRCLR(EARRAY);
EARRAY[0]←CVFIL(COREIMAGEFILE,EARRAY[1],EARRAY[3]);
EARRAY[6]←CVSIX("DSK");
EARRAY['14]←CVFIL(E$TEMP,EARRAY['13],EARRAY['11]);
EARRAY['12]←CVSIX("DSK");
EARRAY['13]←EARRAY['13] LOR '100000; ! /N mode ;
EARRAY['15]←1; ! line no = 1;
EARRAY['16]←1; ! page no = 1;
EARRAY['17]←(LOCATION(SAVADR[0]) LSH 18) LOR LOCATION(GETADR[0]);
BRK_N;
PRINT("I am swapping to the Editor; when you are done with the Editor, type
<control>XRUN to resume. If you get out of E by typing <control>E, get
back into E by typing CONT and resume by typing <control>XRUN.
If you lose your core image, you can resume by doing a RU "&COREIMAGEFILE&"
");
SWAP0(SAVADR,GETADR,EARRAY);
DELFILE(COREIMAGEFILE);
MODIFY_STRING←READFILE(E$TEMP);
DELFILE(E$TEMP);
END;
! readcode;
INTERNAL PROCEDURE READCODE(STRING FID; BOOLEAN ECHO(FALSE));
BEGIN
PUSHDEVSTACK;
$INPCH←OREADFILE(FID,$EOF);
IFC #DISPL THENC $ALLOW←$ALLOW+1; IF ECHO THEN DPYFREE; ENDC
DEVICE←DSK_X;
NEWFILE←TRUE; FILEPRINT←ECHO;
END;
! editcall,renamecall;
RPTR(SYMBOL) $VAR; ! sticky argument for EDITCALL;
RPTR(EXPR$) $VAREXPR;
INTERNAL PROCEDURE EDITCALL;
BEGIN
BOOLEAN DEFAULT;
GTOKEN(FALSE); ! in case he left out the argument ;
DEFAULT←FALSE;
IF FINAL THEN DEFAULT←TRUE
ELSE IF TOKENPTR=NULL_RECORD THEN ERROR("Unknown identifier")
ELSE $VAR←TOKENPTR;
IF $VAR=NULL_RECORD THEN ERROR("Need argument since no argument so far");
IF SYMBOL:TYPE[$VAR]=#MC
THEN BEGIN
INTEGER BRCHAR;
STRING OLD_STRING,NEW_STRING,LINE_STRING;
OLD_STRING← "REDEFINE "&MACRO:HEAD[SYMBOL:OBJECT[$VAR]]
&" = "&CVSYM($VAR,EDIT_D)&";";
NEW_STRING←LINE_STRING←NULL;
WHILE OLD_STRING DO
BEGIN LINE_STRING←SCAN(OLD_STRING,$CRTAB,BRCHAR);
LODED(LINE_STRING&CR);
NEW_STRING←NEW_STRING&INCHWL&CRLF;
END;
ASKUSER(";"&NEW_STRING);
END
ELSE
BEGIN
RPTR(EXPR$)E; RPTR(SYMBOL)S;INTEGER TYPE;
IF (TYPE←SYMBOL:TYPE[$VAR])=#PR OR (TYPE=#EV) OR (TYPE=#CM)
THEN ERROR("Cant edit "&$DTYPE[TYPE]&" yet")
ELSE IF PRDECL($VAR)
THEN ERROR(SYMBOL:PNAME[$VAR]," is a POINTY defined variable or constant and cannot be changed")
ELSE IF SYMBOL:ACCESS[$VAR]=#ARRAY
THEN ERROR("Cant edit array elements yet");
IF NOT DEFAULT THEN
BEGIN STOKEN←TRUE; $VAREXPR←IDREF(S); $VAR←S; END;
SEMICOL_READ; ! leave there to avoid troubles;
PRINT("value of ",SYMBOL:PNAME[$VAR]," = ");
LODED(CVEXPR($VAREXPR,EDIT_D)&CR);
ASKUSER;
ASGEX2($VAR,$VAREXPR);
END;
END;
INTERNAL PROCEDURE RENAMCALL;
BEGIN
STRING NEW; RPTR(SYMBOL) TPTR;
GTOKEN;
IF #TOKEN≠UNDECLARED_TYPE THEN ERROR("RENAME: Need undeclared token");
NEW←TOKEN;
WORD_READ("←");
GTOKEN;
IF #TOKEN≠ID_TYPE OR SYMBOL:ACCESS[TPTR←TOKENPTR]≠#SIMPLE THEN ERROR
("RENAME: can only change names of simple variables currently");
! SEMICOL_READ; ! commented out for cleaning;
SYMBOL:PNAME[TPTR]←NEW; ! changes the name in record symbol;
IF SYMBOL:TYPE[TPTR]=#FR
THEN FRAME:PNAME[SYMBOL:OBJECT[TPTR]]←NEW;
END;
! readcall,renmcall,writecall,photocall,helpcall;
IFC #OUTPT THENC
INTERNAL PROCEDURE READCALL(BOOLEAN ECHO(TRUE));
BEGIN
STRING FILE;
FILE←"DECLAR.AL"; ! default value;
GTOKEN(FALSE);
IF NOT FINAL
THEN BEGIN
STOKEN←TRUE;FILE←NAME_OF_FILE;
SEMICOL_READ; ! commented out by mlg;
STOKEN←TRUE;
END;
READCODE(FILE,ECHO);
END;
INTERNAL PROCEDURE WRITCALL;
BEGIN "A"
STRING FILE;
INTEGER NELEMENTS,I;
RPTR(SYMBOL)ARRAY ELEMENTS[1:20];
NELEMENTS←0;
FILE←$ALFL; ! default values;
GTOKEN(FALSE);
IF NOT FINAL
THEN CASE #TOKEN OF
α
[RES_TYPE]
IF EQU(TOKEN,"INTO") THEN STOKEN←TRUE
ELSE IF ¬EQU(TOKEN,"ALL") THEN ERROR("Can't use "&TOKEN&
" as argument to be saved in a write statement");
[ID_TYPE]
DO α
IF (NELEMENTS←NELEMENTS+1)>21 THEN ERROR("Cant output more than 21 elements in one statement");
ELEMENTS[NELEMENTS]←TOKENPTR;
GTOKEN(FALSE);
IF TOKEN="," THEN GTOKEN
ELSE IF FINAL THEN DONE
ELSE STOKEN←TRUE;
β UNTIL #TOKEN≠ID_TYPE;
ELSE ERROR("Can't write out the value of "&TOKEN)
β;
GTOKEN(FALSE);
IF NOT FINAL
THEN IF ¬EQU(TOKEN,"INTO") THEN
ERROR("Need INTO here before putting in file name, but you have got "&token)
ELSE FILE←NAME_OF_FILE;
IF NELEMENTS=0 THEN WRITECODE(FILE,NULL_RECORD)
ELSE FOR I←1 STEP 1 UNTIL NELEMENTS DO WRITECODE(FILE,ELEMENTS[I]);
END "A";
ENDC
INTERNAL PROCEDURE PHOTOCALL(STRING FILE);
BEGIN
! SEMICOL_READ; ! commented out for cleaning;
IFC #OUTPT THENC TTYSAVE(FILE); ENDC ! file status modified;
$OULST←NULL;
END;
INTERNAL PROCEDURE HELPCALL;
HELP;
! display: update,arrow,displaycall,redisplaycall,showcall,nodisplaycall;
IFC ¬ #ARROW THENC
INTERNAL SIMPLE PROCEDURE ARROW; ;
ENDC
IFC #DISPL THENC
INTEGER MDISPLAY; ! display mode;
DEFINE TABLE_DISPLAY=0,
TYPE_DISPLAY=1,
SYMBOL_DISPLAY=2,
NO_DISPLAY=3;
SIMPLE STRING PROCEDURE DEFAULT;
RETURN(" "&OLDCMD&CRLF&" "&OLDOBJ&CRLF);
RCLASS SYMBOL_LIST(RPTR(SYMBOL_LIST)NEXT;RPTR(SYMBOL)PTR);
RPTR(SYMBOL_LIST) DISPLAY_LIST;
INTEGER TDISPLAY;
BOOLEAN NDISPLAY;
PROCEDURE DPYELM(STRING S);
OUTDPW(
"########################### SELECTED VARIABLES ############################"
&crlf&S&crlf&
"###########################################################################",
-3,-2);
PROCEDURE DPYVAR(INTEGER VARTYPE);
IF NOT $DISPLAYLIST[VARTYPE] THEN
OUTDPW(
("************************* CURRENT "&$DTYPE[VARTYPE]&"S ***********************************************")
[1 TO 74]&crlf&($DISPLAYLIST[VARTYPE]←DPY_STRING(VARTYPE))&
"***************************************************************************"
,-3,-3);
PROCEDURE DPYSYMS;
BEGIN STRING S;
RPTR(SYMBOL)SYM;
RPTR(SYMBOL_LIST)SYL;
SYL←DISPLAY_LIST;
S←NULL;
WHILE SYL≠NULL_RECORD
DO BEGIN
S←S&CVSSYM(SYMBOL_LIST:PTR[SYL])&CRLF;
SYL←SYMBOL_LIST:NEXT[SYL];
END;
DPYELM(S);
END;
INTERNAL PROCEDURE UPDATE;
IF $ALLOW=0 THEN $UPDATED←FALSE;
! update the display (if $ALLOW=0);
INTERNAL PROCEDURE RENEW;
BEGIN INTEGER I;
$UPDATED←TRUE;
CASE MDISPLAY OF
BEGIN
[TABLE_DISPLAY]
BEGIN
DPYDRAW;
FOR I←#SC,#VT,#TR,#RT,#FR DO
$DISPLAYLIST[I]←DPY_STRING(I);
IFC #OUTPT THENC IF NOT $OULST THEN $OULST←FILE_STRING;ENDC
$DFLST←DEFAULT;
OUTDPY;
DPYOUT(1);
END;
[NO_DISPLAY]
IF NDISPLAY THEN
BEGIN
OUTDPW(
"**************************** P O I N T Y **********************************
DISPLAY SUPPRESSED; TYPE REDISPLAY TO GET BACK DISPLAY TABLE
TYPE DISPLAY SCALARS TO DISPLAY SCALARS
****************************************************************************
",-3,-2); NDISPLAY←FALSE;
END;
[TYPE_DISPLAY]
DPYVAR(TDISPLAY);
[SYMBOL_DISPLAY]
DPYSYMS
END;
ESC_P;
END;
ENDC
IFC #DISPL THENC
INTERNAL PROCEDURE REDISPLAYCALL;
BEGIN
! SEMICOL_READ; ! commented out for cleaning;
$ALLOW←0;
TDISPLAY←0;
MDISPLAY←TABLE_DISPLAY;
DISPLAY_LIST←NULL_RECORD;
END;
INTERNAL PROCEDURE NODISPLAYCALL;
BEGIN
! SUPPRESS DISPLAY;
! SEMICOL_READ; ! commented out for cleaning;
NDISPLAY←TRUE;
MDISPLAY←NO_DISPLAY;
DISPLAY_LIST←NULL_RECORD;
END;
INTERNAL PROCEDURE DISPLAYCALL;
BEGIN
INTEGER TT;
GTOKEN;
FOR TT←#MIN STEP 1 UNTIL #MAX DO
IF EQU(TOKEN,$DTYPE[TT]) OR EQU(TOKEN,$DTYPE[TT]&"S") THEN DONE;
IF TT≤#MAX THEN TDISPLAY←TT
ELSE ERROR("No such data type: "&TOKEN&CRLF);
! add the possibility of asking <type> PROCEDURE;
GTOKEN(FALSE);
IF NOT FINAL
THEN IF (EQU(TOKEN,"PROCEDURE") OR EQU(TOKEN,"PROCEDURES"))
AND #MIN≤TDISPLAY≤#BASIC_TYPES
THEN TDISPLAY←TDISPLAY+#MAX
ELSE ERROR("Only typed procedures or basic data types accepted");
MDISPLAY←TYPE_DISPLAY;
END;
INTERNAL PROCEDURE SHOWCALL;
BEGIN
RPTR(SYMBOL_LIST)SL1,SL2;
SL1←SL2←NEW_RECORD(SYMBOL_LIST);
DO BEGIN
GTOKEN;
IF TOKENPTR=NULL_RECORD
THEN ERROR("SHOW: Need a macro, procedure or variable name after SHOW");
SYMBOL_LIST:NEXT[SL2]←SL2←NEW_RECORD(SYMBOL_LIST);
SYMBOL_LIST:PTR[SL2]←TOKENPTR;
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL THEN ERROR("Need a comma to separate arguments");
END UNTIL FINAL;
MDISPLAY←SYMBOL_DISPLAY;
DISPLAY_LIST←SYMBOL_LIST:NEXT[SL1];
END;
ENDC
! graphcall;
IFC #GATHER THENC
INTERNAL PROCEDURE GRAPHCALL;
BEGIN
IF GRAPTR=NULL_RECORD THEN ERROR("GRAPH: no data currently available");
BRK_N;
GRAPH(GRAPHREC:DATA[GRAPTR],
GRAPHREC:CTLBITS[GRAPTR],
GRAPHREC:NPNTS[GRAPTR],
GRAPHREC:SIZE[GRAPTR]);
GRAPTR←NULL_RECORD;
END;
INTERNAL PROCEDURE TGRAPHCALL;
BEGIN
TEXEC;
GRAPHCALL;
END;
ENDC
! eeditcall;
INTERNAL PROCEDURE EEDITCALL;
BEGIN
RPTR(SYMBOL)EL;INTEGER OBTYPE;STRING FBODY;
RPTR(SCALAR,VECTOR,TRANS,FRAME,ROT,MACRO) TEMP;
STRING VAR;
VAR←IDF_READ;
SEMICOL_READ;
EL←OLDSYM(VAR,OBTYPE); ! var must exist in $YMTAB;
TEMP←SYMBOL:OBJECT[EL];
IF OBTYPE = #MC
THEN BEGIN
INTEGER BRCHAR;
STRING OLD_STRING;
OLD_STRING← "REDEFINE "&MACRO:HEAD[SYMBOL:OBJECT[EL]]
&" = "&CVSYM(EL,EDIT_D)&";";
ESWAP(OLD_STRING);
ASKUSER(OLD_STRING);
END
ELSE ERROR("EEDIT: only valid for macros");
END;
ifc false thenc
! deletecall,definecall,notavailcall,exitcall;
INTERNAL PROCEDURE DELETECALL(BOOLEAN QUIET(FALSE));
BEGIN
STRING VAR;
GTOKEN(FALSE);
IF FINAL OR EQU(TOKEN,"ALL")
THEN IF QUIET OR EQU(TOKEN,"ALL") THEN RESET
ELSE BEGIN ! deletes all the variables;
STRING ANSWER;
PRINT("are you sure all variables are to be deleted? ");
ANSWER←INCHRW;
PRINT(CRLF);ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN RESET
ELSE ERROR("instruction not executed");
END
ELSE BEGIN "delete elements"
RPTR(RSTACK)SSPTR;
INTEGER #ELEM,I; #ELEM←0;
STOKEN←TRUE; SSPTR←NEW_RSTACK;
DO BEGIN "A"
GTOKEN;
IF TOKENPTR THEN
BEGIN
! check if already on the list ;
BOOLEAN FOUND;
IF PRDECL(TOKENPTR) THEN ERROR("DELETE: trying to delete a POINTY declared variable",TOKEN);
FOUND←FALSE;
FOR I←1 STEP 1 UNTIL #ELEM DO
IF RSTACK:STACK[SSPTR][I]=TOKENPTR THEN
BEGIN FOUND←TRUE; DONE; END;
IF NOT FOUND THEN
BEGIN
#ELEM←#ELEM+1;
RPUSH(SSPTR,TOKENPTR);
END;
END
ELSE IF NOT QUIET THEN ERROR("DELETE: unknown token ", TOKEN);
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL THEN ERROR("; or , required");
END "A"
UNTIL FINAL;
FOR I←1 STEP 1 UNTIL #ELEM DO
KILLVAR(RSTACK:STACK[SSPTR][I]);
END "delete elements";
END;
PROCEDURE DEFINECODE(BOOLEAN REDEF);
BEGIN RPTR(MACRO) MACPTR; STRING MACNAME; INTEGER DDLCOUNT; STRING BODY,NBODY;
! redef is true if it is a redefinition;
INTEGER NPARAM; NPARAM←0;
GTOKEN;
IF REDEF THEN
BEGIN ! check if it already exists;
IF TOKENPTR=NULL_RECORD OR SYMBOL:TYPE[TOKENPTR]≠#MC
THEN ERROR("REDEFINE: "&TOKEN&" is not a macro name");
MACPTR←SYMBOL:OBJECT[TOKENPTR];
END
ELSE IF #TOKEN ≠ UNDECLARED_TYPE
THEN ERROR("MACRO DEFINITION: need undeclared identifier")
ELSE MACPTR←NEW!RECORD(MACRO);
DDLCOUNT ← 0;
MACNAME ← TOKEN;
GTOKEN;
IF TOKEN≠"("
THEN BEGIN STOKEN←TRUE; MACRO:HEAD[MACPTR]←MACNAME; END
ELSE
BEGIN "parametered macro"
RCLASS PLIST(STRING PARAM; RPTR(PLIST) NEXTP);
RPTR(PLIST) TEMP,TEMP0;
TEMP0←NULL_RECORD;
DO
BEGIN "get parameters"
GTOKEN;
IF #TOKEN ≠ UNDECLARED_TYPE THEN
ERROR("MACRO DEFINITION: need undeclared token for argument");
NPARAM←NPARAM+1;
TEMP←NEW!RECORD(PLIST);
PLIST:NEXTP[TEMP]←TEMP0;
PLIST:PARAM[TEMP]←TOKEN;
TEMP0←TEMP;
WORD2_READ(",",")");
END "get parameters" UNTIL TOKEN=")";
BEGIN
INTEGER I; STRING ARRAY S[1:NPARAM];
STRING HEAD; HEAD←")";
FOR I←NPARAM STEP -1 UNTIL 1 DO
BEGIN
HEAD←","&(S[I]←PLIST:PARAM[TEMP])&HEAD;
TEMP←PLIST:NEXTP[TEMP];
END;
MEMORY[LOCATION(S)]↔MEMORY[LOCATION(MACRO:PRLIST[MACPTR])];
MACRO:HEAD[MACPTR]←MACNAME&"("&HEAD[2 TO ∞];
END;
MACRO:NPARAM[MACPTR]←NPARAM;
END "parametered macro";
WWORD_READ("=","⊂"); DDLCOUNT ← 1;
BODY←"⊂";
DO BEGIN
INTEGER I;
I←READTILL("⊂⊃");
BODY←BODY&TOKEN&I;
IF I="⊂"
THEN DDLCOUNT ← DDLCOUNT + 1
ELSE DDLCOUNT ← DDLCOUNT - 1;
END UNTIL DDLCOUNT=0;
BODY←BODY[2 TO ∞-1];
IF NPARAM>0 THEN
BEGIN
NBODY←NULL;
WHILE BODY DO
BEGIN "process the parameters"
INTEGER I;
INTEGER BRCHAR; STRING TTOKEN;
NBODY←NBODY&SCAN(BODY,$LTTAB,BRCHAR);
TTOKEN←SCAN(BODY,$NLTTAB,BRCHAR);
FOR I←1 STEP 1 UNTIL NPARAM
DO IF EQU(MACRO:PRLIST[MACPTR][I],TTOKEN) THEN DONE;
IF I>NPARAM THEN
NBODY←NBODY&TTOKEN
ELSE NBODY←NBODY&DUMMY_DELIM&TTOKEN&DUMMY_DELIM;
END "process the parameters";
END ELSE NBODY←BODY;
MACRO:BODY[MACPTR]←NBODY;
! SEMICOL_READ; ! commented out for cleaning;
IF NOT REDEF THEN ENSYM(MACNAME, #MC, MACPTR);
! enter into symbol table if a define ;
$MCLST←NULL;
END;
INTERNAL PROCEDURE DEFINECALL(BOOLEAN REDEF(FALSE));
BEGIN
DO BEGIN
DEFINECODE(REDEF);
GTOKEN(FALSE);
END UNTIL TOKEN≠",";
STOKEN←TRUE;
END;
INTERNAL PROCEDURE NOTAVAILCALL;
BEGIN
PRINT(TOKEN & " " &#VERSION);
OUTSTR("Will flush this statement"&crlf);
DO GTOKEN(FALSE) UNTIL FINAL;
END;
INTERNAL PROCEDURE EXITCALL;
endc
! deletecall,definecall,notavailcall,exitcall;
INTERNAL PROCEDURE DELETECALL(BOOLEAN QUIET(FALSE));
BEGIN
STRING VAR;
GTOKEN(FALSE);
IF FINAL OR EQU(TOKEN,"ALL")
THEN IF QUIET OR EQU(TOKEN,"ALL") THEN RESET
ELSE BEGIN ! deletes all the variables;
STRING ANSWER;
PRINT("are you sure all variables are to be deleted? ");
ANSWER←INCHRW;
PRINT(CRLF);ESC_P;
IF ANSWER="Y" OR ANSWER="y"
THEN RESET
ELSE ERROR("instruction not executed");
END
ELSE BEGIN "delete elements"
RPTR(RSTACK)SSPTR;
INTEGER #ELEM,I; #ELEM←0;
STOKEN←TRUE; SSPTR←NEW_RSTACK;
DO BEGIN "A"
GTOKEN;
IF TOKENPTR THEN
BEGIN
! check if already on the list ;
BOOLEAN FOUND;
IF PRDECL(TOKENPTR) THEN ERROR("DELETE: trying to delete a POINTY declared variable",TOKEN);
FOUND←FALSE;
FOR I←1 STEP 1 UNTIL #ELEM DO
IF RSTACK:STACK[SSPTR][I]=TOKENPTR THEN
BEGIN FOUND←TRUE; DONE; END;
IF NOT FOUND THEN
BEGIN
#ELEM←#ELEM+1;
RPUSH(SSPTR,TOKENPTR);
END;
END
ELSE IF NOT QUIET THEN ERROR("DELETE: unknown token ", TOKEN);
GTOKEN(FALSE);
IF TOKEN≠"," AND NOT FINAL THEN ERROR("; or , required");
END "A"
UNTIL FINAL;
FOR I←1 STEP 1 UNTIL #ELEM DO
KILLVAR(RSTACK:STACK[SSPTR][I]);
END "delete elements";
END;
PROCEDURE DEFINECODE(BOOLEAN REDEF);
BEGIN RPTR(MACRO) MACPTR; STRING MACNAME; INTEGER DDLCOUNT; STRING BODY,NBODY;
! redef is true if it is a redefinition;
INTEGER NPARAM,NON_DEFAULT_ARGS; BOOLEAN DEFAULT_PARAM;
NPARAM←0; DEFAULT_PARAM←FALSE; GTOKEN;
IF REDEF THEN
BEGIN ! check if it already exists;
IF TOKENPTR=NULL_RECORD OR SYMBOL:TYPE[TOKENPTR]≠#MC
THEN ERROR("REDEFINE: "&TOKEN&" is not a macro name");
MACPTR←SYMBOL:OBJECT[TOKENPTR];
END
ELSE IF #TOKEN ≠ UNDECLARED_TYPE
THEN ERROR("MACRO DEFINITION: need undeclared identifier")
ELSE MACPTR←NEW!RECORD(MACRO);
DDLCOUNT ← 0;
MACNAME ← TOKEN;
GTOKEN;
IF TOKEN≠"("
THEN BEGIN STOKEN←TRUE; MACRO:HEAD[MACPTR]←MACNAME; END
ELSE
BEGIN "parametered macro"
RCLASS PLIST(STRING PARAM,DEFAULT_VAL; RPTR(PLIST) NEXTP);
RPTR(PLIST) TEMP,TEMP0;
TEMP0←NULL_RECORD;
DO BEGIN "get parameters"
GTOKEN;
IF #TOKEN ≠ UNDECLARED_TYPE THEN
ERROR("MACRO DEFINITION: need undeclared token for argument");
NPARAM←NPARAM+1;
TEMP←NEW!RECORD(PLIST);
PLIST:NEXTP[TEMP]←TEMP0;
PLIST:PARAM[TEMP]←TOKEN;
TEMP0←TEMP;
GTOKEN;
IF TOKEN="(" THEN
BEGIN "default argument"
INTEGER DCOUNT,PCOUNT,I; STRING DARG;
DEFAULT_PARAM←TRUE;
DCOUNT←0; PCOUNT←1; DARG←"(";
DO BEGIN
I←READTILL("()⊂");
DARG←DARG&TOKEN&I;
IF I="⊂" THEN
BEGIN DCOUNT←1;
DO BEGIN I←READTILL("⊂⊃");
DARG←DARG&TOKEN&I;
IF I="⊂" THEN DCOUNT←DCOUNT+1 ELSE DCOUNT←DCOUNT-1;
END UNTIL DCOUNT=0;
END
ELSE IF I="(" THEN PCOUNT←PCOUNT+1
ELSE PCOUNT←PCOUNT-1;
END UNTIL PCOUNT=0;
PLIST:DEFAULT_VAL[TEMP]←DARG;
WORD2_READ(",",")");
END "default argument"
ELSE IF DEFAULT_PARAM THEN ERROR("Need default parameter here")
ELSE IF TOKEN≠"," AND TOKEN≠")" THEN ERROR("Need , or ) here")
ELSE NON_DEFAULT_ARGS←NON_DEFAULT_ARGS+1;
END "get parameters" UNTIL TOKEN=")";
BEGIN
INTEGER I; STRING ARRAY S,D[1:NPARAM];
STRING HEAD; HEAD←")";
FOR I←NPARAM STEP -1 UNTIL 1 DO
BEGIN
HEAD←","&(S[I]←PLIST:PARAM[TEMP])&
(D[I]←PLIST:DEFAULT_VAL[TEMP])&HEAD;
TEMP←PLIST:NEXTP[TEMP];
END;
MEMORY[LOCATION(S)]↔MEMORY[LOCATION(MACRO:PRLIST[MACPTR])];
MEMORY[LOCATION(D)]↔MEMORY[LOCATION(MACRO:DEFAULT_ARG[MACPTR])];
MACRO:HEAD[MACPTR]←MACNAME&"("&HEAD[2 TO ∞];
END;
MACRO:NPARAM[MACPTR]←NPARAM;
END "parametered macro";
WWORD_READ("=","⊂"); DDLCOUNT ← 1;
BODY←"⊂";
DO BEGIN
INTEGER I;
I←READTILL("⊂⊃");
BODY←BODY&TOKEN&I;
IF I="⊂"
THEN DDLCOUNT ← DDLCOUNT + 1
ELSE DDLCOUNT ← DDLCOUNT - 1;
END UNTIL DDLCOUNT=0;
BODY←BODY[2 TO ∞-1];
IF NPARAM>0 THEN
BEGIN
NBODY←NULL;
WHILE BODY DO
BEGIN "process the parameters"
INTEGER I;
INTEGER BRCHAR; STRING TTOKEN;
NBODY←NBODY&SCAN(BODY,$LTTAB,BRCHAR);
TTOKEN←SCAN(BODY,$NLTTAB,BRCHAR);
FOR I←1 STEP 1 UNTIL NPARAM
DO IF EQU(MACRO:PRLIST[MACPTR][I],TTOKEN) THEN DONE;
IF I>NPARAM THEN
NBODY←NBODY&TTOKEN
ELSE NBODY←NBODY&DUMMY_DELIM&TTOKEN&DUMMY_DELIM;
END "process the parameters";
END ELSE NBODY←BODY;
MACRO:BODY[MACPTR]←NBODY;
! SEMICOL_READ; ! commented out for cleaning;
IF NOT REDEF THEN ENSYM(MACNAME, #MC, MACPTR);
! enter into symbol table if a define ;
$MCLST←NULL;
END;
INTERNAL PROCEDURE DEFINECALL(BOOLEAN REDEF(FALSE));
BEGIN
DO BEGIN
DEFINECODE(REDEF);
GTOKEN(FALSE);
END UNTIL TOKEN≠",";
STOKEN←TRUE;
END;
INTERNAL PROCEDURE NOTAVAILCALL;
BEGIN
PRINT(TOKEN & " " &#VERSION);
OUTSTR("Will flush this statement"&crlf);
DO GTOKEN(FALSE) UNTIL FINAL;
END;
INTERNAL PROCEDURE EXITCALL;
ENDIT;
! requirecall,bailcall,setstatuscall,readmesscall,stopmesscall;
INTERNAL PROCEDURE REQUIRECALL;
BEGIN
GTOKEN;
IF EQU(TOKEN,"SOURCE_FILE") THEN READCALL(FILEPRINT)
ELSE IF EQU(TOKEN,"ERROR_MODES") OR EQU(TOKEN,"COMPILER_SWITCHES")
THEN STR_READ
ELSE IF EQU(TOKEN,"BAIL") THEN BAILCALL
ELSE IF EQU(TOKEN,"QBAIL") THEN QBLCALL
ELSE IF EQU(TOKEN,"MESSAGE") THEN PRINT(STR_READ)
ELSE ERROR(TOKEN," is invalid for REQUIRE");
END;
INTERNAL PROCEDURE BAILCALL;
BAILCODE;
INTERNAL PROCEDURE QBLCALL;
QBAILCODE;
INTERNAL PROCEDURE SETSTATUSCALL(INTEGER VARVALUE);
BEGIN
! this procedure is to set the values of certain POINTY system variables
in the SAIL part for program control : it takes a VARIABLE and an integer
and assigns the value of the string to the variable name ;
INTEGER I; STRING VARNAME,PRNAME;
WORD_READ("(");
GTOKEN;
VARNAME←TOKEN;
IF VARVALUE=1 THEN PRNAME←"SETSTATUS:" ELSE PRNAME←"RESETSTATUS:";
GTOKEN;
IF TOKEN=","
THEN BEGIN
GTOKEN;
IF #TOKEN≠INT_TYPE THEN ERROR(PRNAME," Need integer argument");
VARVALUE←INTSCAN(TOKEN,I);
END
ELSE STOKEN←TRUE;
IF EQU(VARNAME,"PPCODE") THEN !PPCODE←VARVALUE
ELSE IF EQU(VARNAME,"LINE") THEN !LINE←VARVALUE
ELSE IF EQU(VARNAME,"PWCODE") THEN !PWCODE←VARVALUE
ELSE IF EQU(VARNAME,"NOFOLD") THEN !NOFOLD←VARVALUE
ELSE IF EQU(VARNAME,"ALPRIN") THEN !ALPRIN←VARVALUE
ELSE IF EQU(VARNAME,"PRTIME") THEN !PRTIME←VARVALUE
ELSE IF EQU(VARNAME,"DEBUG") THEN !DEBUG←VARVALUE
ELSE IF EQU(VARNAME,"NOELF") THEN
BEGIN $NOELF←VARVALUE;
IF $ELFUNAVAILABLE THEN ERROR("This is no good. I cant get access to the ELF!!!");
END
ELSE ERROR(PRNAME," valid arguments are PPCODE,PWCODE,LINE,NOELF,NOFOLD,ALPRIN,PRTIME,DEBUG");
WORD_READ(")");
END;
INTERNAL PROCEDURE READMESSCALL;
BEGIN
PUSHDEVSTACK;
DEVICE←MESSAGE_X;
END;
INTERNAL PROCEDURE STOPMESSCALL;
BEGIN
$CLNE←$CLINR←NULL;
POPDEVSTACK;
END;
! savecorecall;
STRING RSUME_STRING;
PROCEDURE RESUME0;
RSUME_STRING←NULL;
REQUIRE RESUME0 INITIALIZATION;
INTERNAL PROCEDURE RSUMEMESSCALL;
BEGIN
WORD_READ("(");
RSUME_STRING←STR_READ;
WORD_READ(")");
END;
INTERNAL PROCEDURE SAVECORECALL(STRING FILE);
IF $NOELF OR $ELFUNAVAILABLE THEN ERROR("ELF unavailable, cant save state")
ELSE
BEGIN
BOOLEAN SAMECOREIMAGE; INTEGER I;
INTEGER ARRAY ELFMEM[1:'500000/4+1];
INTEGER ARRAY SAVADR[0:4],GETADR[0:5],ACCUM[0:'17];
SAVADR[0]←CVSIX("DSK");
SAVADR[1]←CVFIL(FILE,SAVADR[2],SAVADR[4]);
IF SAVADR[1]=CVSIX("POINTY") THEN ERROR("SAVECORE: dont use dumpfile POINTY");
IF SAVADR[2]≠CVSIX("DMP") THEN
BEGIN PRINT(CRLF,"I will give extension of .DMP");
SAVADR[2]←CVSIX("DMP");
END;
ARRCLR(GETADR);
ARRCLR(ACCUM);
ACCUM['17]←(LOCATION(SAVADR[0]) LSH 18);
SAV11(ELFMEM);
SAMECOREIMAGE←SWAP0(SAVADR,GETADR,ACCUM);
IF NOT SAMECOREIMAGE THEN
BEGIN
RES11(ELFMEM); ! only restore if run from disk ;
INIT0;
PRINT(RSUME_STRING);
END;
RESTRT11('1014);
END;
END "PCALL";